home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / SysGen / defer < prev    next >
Encoding:
Text File  |  1992-06-01  |  1.8 KB  |  79 lines
  1. \ VECTORED EXECUTION
  2. \ works sep16/86. can replace all exec-var-by etc...
  3. \ OCT 1 86, CHANGED "WAS" TO "WHAT'S"  makes more sense to say:
  4. \    WHAT'S EMIT  than  WAS EMIT 
  5. \ 23-apr-91 mdh rewitten deferred words
  6. \ 00001 PLB 12/5/91 Fixed error message in IS
  7.  
  8.  
  9. DECIMAL
  10. \ FORTH DEFINITIONS
  11. \ INCLUDE? FORGET FORGET 
  12.  
  13. .NEED COMPILING?  
  14. : COMPILING?  ( --- FLAG )  STATE @  ;
  15. .THEN
  16.  
  17.  
  18. \ INCLUDE? >PARENT JF:PARENT
  19.  
  20. DECIMAL 
  21. \ EXEC-VAR etc replaced by DEFER and DEFER-GLOBAL
  22.  
  23. decimal 10 constant DEFER-SIZE  \ see len of code created by GLOBAL-DEFER...
  24.  
  25. : GLOBAL-DEFER  ( -- )
  26.   [compile] :
  27.   $ 207A,0008 ,   \  4 - move.l  $8(pc),a0
  28. \ $ 4EB0,C800 ,   \  8 - jsr     $0(a0,org.l)
  29.   $ 4EF0,C800 ,   \  8 - jmp     $0(a0,org.l)
  30.   1 state !
  31.   [compile] ;     \ 10 - rts
  32.   state off
  33.   last-sfa drop dup @  GLOBDEF_ID or  swap !
  34.   ' quit ,        \ cfa placeholder
  35. ;
  36. \ GLOBAL-DEFER GLOBAL-DEFER-EXAMPLE
  37.  
  38. : DEFER   ( --- )  ( function-name --in-- ) 
  39.   global-defer
  40.   \ last-sfa drop dup @  USERDEF_ID or  swap !
  41. ; 
  42. \ DEFER DEFER-EXAMPLE
  43.  
  44. : IsDefered? ( cfa -- flag )
  45.   cell- @ $ f,0000 and GLOBDEF_ID =
  46. ;
  47.  
  48. : >IS  ( CFA --- DATA-ADDRESS )
  49.   dup IsDefered? 
  50.   IF
  51.      DEFER-SIZE +
  52.   ELSE
  53.      >newline ." >IS : not deferred : " >name id.  QUIT 
  54.   THEN
  55. ;
  56.  
  57. : IS    ( CFA --- )  ( deffered-var--in-- )
  58.   BL WORD FIND NOT
  59.   IF
  60.       >newline  ." IS : can't find : "
  61. \      >name id.  \ 00001 didn't FIND so no CFA for >NAME !!!
  62.     count type \ 00001 TYPE instead
  63.       quit  
  64.   THEN   COMPILING?  
  65.   IF    [compile] aliteral  compile >is  compile !
  66.   ELSE  >IS   ! 
  67.   THEN
  68. ; IMMEDIATE
  69.  
  70.  
  71.  
  72. : WHAT'S   ( --- CFA )  ( deffered-var --in-- ) BL WORD FIND NOT
  73.    IF  >newline ." WHAT'S : can't find : " >name id. quit 
  74.    THEN
  75.    COMPILING?  
  76.    IF    [compile] aliteral  compile >is  compile @   \ COMPILE <WHAT'S> , 
  77.    ELSE  >IS   @ 
  78.    THEN  ; IMMEDIATE
  79.